home *** CD-ROM | disk | FTP | other *** search
/ Experimental BBS Explossion 3 / Experimental BBS Explossion III.iso / pascal / tvtool2.zip / TVSTRING.PAS < prev    next >
Pascal/Delphi Source File  |  1993-07-20  |  24KB  |  984 lines
  1. {*
  2. *   TV Tool Box Version 2.0
  3. *   Copyright (c) 1992, 1993 by Richard W. Hansen
  4. *   All Rights Reserved
  5. *
  6. *
  7. *   TvString.pas
  8. *   Turbo Vision string routines for Turbo Pascal 7.0.
  9. *
  10. *}
  11.  
  12. UNIT TvString;
  13. {$B+}
  14. {$X+}
  15. {$V-}
  16. {.$N+}
  17.  
  18. {$I TVDEFS.INC}
  19.  
  20. INTERFACE
  21.  
  22.  
  23. USES
  24.   TvConst, TvType;
  25.  
  26.  
  27. CONST
  28.   HexDigits   : Array[0..$F] of Char = '0123456789ABCDEF';
  29.  
  30.  
  31. TYPE
  32.   TbxNumberMask  = String[30];
  33.  
  34.  
  35. Procedure Pad(var S   : String;
  36.                   Len : Byte);
  37.   {- pad S to Len characters with spaces  }
  38.  
  39. Procedure LeftPad(var S   : String;
  40.                       Len : Byte);
  41.   {- left pad S to Len characters with spaces  }
  42.  
  43. Procedure PadCh(var S   : String;
  44.                     Len : Byte;
  45.                     Ch  : Char);
  46.   {- pad S to Len characters with Ch  }
  47.  
  48. Procedure LeftPadCh(var S   : String;
  49.                         Len : Byte;
  50.                         Ch  : Char);
  51.   {- left pad S to Len characters with Ch }
  52.  
  53. Procedure Trim(var S : String);
  54.   {- trim leading and trailing spaces from S }
  55.  
  56. Procedure TrimLead(var S : String);
  57.   {- remove leading spaces from S }
  58.  
  59. Procedure TrimTrail(var S : String);
  60.   {- remove trailing spaces from S }
  61.  
  62. Procedure TrimCh(var S  : String;
  63.                      Ch : Char);
  64.   {- trim leading and trailing Ch chars from S }
  65.  
  66. Procedure Strip(var   S     : String;
  67.                 const Chars : TbxCharSet);
  68.   {- remove the characters in Chars from S }
  69.  
  70. Procedure TrimLeadZero(var S : String);
  71.   {- remove leading zeros from S }
  72.  
  73. Procedure TruncateStr(var S   : String;
  74.                           Len : Byte);
  75.   {- Truncate S to the given length }
  76.  
  77. Procedure CopyInto(const InStr  : String;
  78.                          Column : Byte;
  79.                      var OutStr : String);
  80.   {- copy InStr into OutStr beginning at Col }
  81.  
  82.  
  83.  
  84. Function FTrim(S : String): String;
  85.  
  86. Function FTrimLead(S : String): String;
  87.  
  88. Function FTrimTrail(S : String): String;
  89.  
  90. Function FTrimCh(S  : String;
  91.                  Ch : Char): String;
  92.  
  93. Function FPad(S   : String;
  94.               Len : Byte): String;
  95.  
  96. Function FLeftPad(S   : String;
  97.                   Len : Byte): String;
  98.  
  99. Function FPadCh(S   : String;
  100.                 Len : Byte;
  101.                 Ch  : Char): String;
  102.  
  103. Function FLeftPadCh(S   : String;
  104.                     Len : Byte;
  105.                     Ch  : Char): String;
  106.  
  107. Function FStrip(S : String;
  108.                 const Chars : TbxCharSet): String;
  109.  
  110. Function FTrimLeadZero(S : String): String;
  111.  
  112. Function FTruncateStr(S   : String;
  113.                       Len : Byte): String;
  114.  
  115. Function FCopyInto(const InStr  : String;
  116.                          Column : Byte;
  117.                          OutStr : String): String;
  118.  
  119.  
  120.  
  121. Function Blanks(Len : Byte): String;
  122.   {- return a string of Len spaces in S }
  123.  
  124. Function Chars(Len : Byte;
  125.                Ch  : Char): String;
  126.   {- return a string of Ch characters of Length Len in S }
  127.  
  128. Function AllBlanks(const S : String): Boolean;
  129.   {- test for an empty string (null or all spaces) }
  130.  
  131. Function HexString(I : LongInt): String;
  132.   {- return I as a Hexadecimal string }
  133.  
  134. {$IFOPT N+}
  135. Function FormatF(const Mask : TbxNumberMask;
  136.                        Flt  : Double;
  137.                        DP   : Integer): String;
  138. {$ELSE}
  139. Function FormatF(const Mask : TbxNumberMask;
  140.                        Flt  : Real;
  141.                        DP   : Integer): String;
  142. {$ENDIF}
  143.  
  144. Function FormatI(const Mask : TbxNumberMask;
  145.                        Long : LongInt): String;
  146.  
  147.  
  148.  
  149. IMPLEMENTATION
  150.  
  151.  
  152. {*
  153. * Name       : Pad
  154. * Purpose    : Return a string right-padded to length Len with blanks.
  155. * Parameters : S - string to pad
  156. *              Len - length to pad to
  157. *}
  158. Procedure Pad(var S   : String;
  159.                   Len : Byte);
  160.   begin
  161.     if (Byte(S[0]) < Len) then
  162.     begin
  163.       FillChar(S[Byte(S[0]) + 1], Len - Byte(S[0]), ' ');
  164.       Byte(S[0]) := Len;
  165.     end;
  166.   end;
  167.  
  168. Function FPad(S   : String;
  169.               Len : Byte): String;
  170.   begin
  171.     Pad(S, Len);
  172.     FPad := S;
  173.   end;
  174.  
  175. {*
  176. * Name       : LeftPad
  177. * Purpose    : Return a string left-padded to length Len with blanks.
  178. * Parameters : S - string to pad
  179. *              Len - length to pad to
  180. *}
  181. Procedure LeftPad(var S   : String;
  182.                       Len : Byte);
  183.  
  184.   var
  185.     X : Byte;
  186.  
  187.   begin
  188.     if (Byte(S[0]) < Len) then
  189.     begin
  190.       X := Len - Byte(S[0]);
  191.       Move(S[1], S[X + 1], Byte(S[0]));
  192.       FillChar(S[1], X, ' ');
  193.       Byte(S[0]) := Len;
  194.     end;
  195.   end;
  196.  
  197. Function FLeftPad(S   : String;
  198.                   Len : Byte): String;
  199.   begin
  200.     LeftPad(S, Len);
  201.     FLeftPad := S;
  202.   end;
  203.  
  204. {*
  205. * Name       : PadCh
  206. * Purpose    : Return a string right-padded to length Len with Ch.
  207. * Parameters : S - string to pad
  208. *              Len - length to pad to
  209. *              Ch - the character to pad with
  210. *}
  211. Procedure PadCh(var S   : String;
  212.                     Len : Byte;
  213.                     Ch  : Char);
  214.   begin
  215.     if (Byte(S[0]) < Len) then
  216.     begin
  217.       FillChar(S[Byte(S[0]) + 1], Len - Byte(S[0]), Ch);
  218.       Byte(S[0]) := Len;
  219.     end;
  220.   end;
  221.  
  222. Function FPadCh(S   : String;
  223.                 Len : Byte;
  224.                 Ch  : Char): String;
  225.   begin
  226.     PadCh(S, Len, Ch);
  227.     FPadCh := S;
  228.   end;
  229.  
  230. {*
  231. * Name       : LeftPadCh
  232. * Purpose    : Return a string left-padded to length Len with Ch.
  233. * Parameters : S - string to pad
  234. *              Len - length to pad to
  235. *              Ch - the character to pad with
  236. *}
  237. Procedure LeftPadCh(var S   : String;
  238.                         Len : Byte;
  239.                         Ch  : Char);
  240.  
  241.   var
  242.     X : Byte;
  243.  
  244.   begin
  245.     if (Byte(S[0]) < Len) then
  246.     begin
  247.       X := Len - Byte(S[0]);
  248.       Move(S[1], S[X + 1], Byte(S[0]));
  249.       FillChar(S[1], X, Ch);
  250.       Byte(S[0]) := Len;
  251.     end;
  252.   end;
  253.  
  254. Function FLeftPadCh(S   : String;
  255.                     Len : Byte;
  256.                     Ch  : Char): String;
  257.   begin
  258.     LeftPadCh(S, Len, Ch);
  259.     FLeftPadCh := S;
  260.   end;
  261.  
  262. {*
  263. * Name       : Trim
  264. * Purpose    : Return a string with leading and trailing blanks removed.
  265. * Parameters : S - string to trim
  266. *}
  267. Procedure Trim(var S : String);
  268.  
  269.   var
  270.     i : Byte;
  271.  
  272.   begin
  273.     while (Byte(S[0]) > 0) and (S[Byte(S[0])] = ' ') do
  274.       Dec(Byte(S[0]));
  275.  
  276.     i := 1;
  277.  
  278.     while (i <= Byte(S[0])) and (S[i] = ' ') do
  279.       Inc(i);
  280.  
  281.     if (i > 1) then
  282.     begin
  283.       Byte(S[0]) := Byte(S[0]) - i + 1;
  284.       Move(S[i], S[1], Byte(S[0]));
  285.     end;
  286.   end;
  287.  
  288. Function FTrim(S : String): String;
  289.   begin
  290.     Trim(S);
  291.     FTrim := S;
  292.   end;
  293.  
  294. {*
  295. * Name       : TrimLead
  296. * Purpose    : Return a string with leading blanks removed.
  297. * Parameters : S - string to trim
  298. *}
  299. Procedure TrimLead(var S : String);
  300.  
  301.   var
  302.     i : Byte;
  303.  
  304.   begin
  305.     i := 1;
  306.  
  307.     while (i <= Byte(S[0])) and (S[i] = ' ') do
  308.       Inc(i);
  309.  
  310.     if (i > 1) then
  311.     begin
  312.       Byte(S[0]) := Byte(S[0]) - i + 1;
  313.       Move(S[i], S[1], Byte(S[0]));
  314.     end;
  315.   end;
  316.  
  317. Function FTrimLead(S : String): String;
  318.   begin
  319.     TrimLead(S);
  320.     FTrimLead := S;
  321.   end;
  322.  
  323. {*
  324. * Name       : TrimTrail
  325. * Purpose    : Return a string with trailing blanks removed.
  326. * Parameters : S - string to trim
  327. *}
  328. Procedure TrimTrail(var S : String);
  329.   begin
  330.     while (Byte(S[0]) > 0) and (S[Byte(S[0])] = ' ') do
  331.       Dec(Byte(S[0]));
  332.   end;
  333.  
  334. Function FTrimTrail(S : String): String;
  335.   begin
  336.     TrimTrail(S);
  337.     FTrimTrail := S;
  338.   end;
  339.  
  340. {*
  341. * Name       : TrimCh
  342. * Purpose    : Return a string with trailing characters of Ch removed.
  343. * Parameters : S - string to trim
  344. *              Ch - the character to be trimmed
  345. *}
  346. Procedure TrimCh(var S  : String;
  347.                      Ch : Char);
  348.  
  349.   var
  350.     i : Byte;
  351.  
  352.   begin
  353.     while (Byte(S[0]) > 0) and (S[Byte(S[0])] = Ch) do
  354.       Dec(Byte(S[0]));
  355.  
  356.     i := 1;
  357.  
  358.     while (i <= Byte(S[0])) and (S[I] = Ch) do
  359.       Inc(i);
  360.  
  361.     if (i > 1) then
  362.     begin
  363.       Byte(S[0]) := Byte(S[0]) - i + 1;
  364.       Move(S[i], S[1], Byte(S[0]));
  365.     end;
  366.   end;
  367.  
  368. Function FTrimCh(S  : String;
  369.                  Ch : Char): String;
  370.   begin
  371.     TrimCh(S, Ch);
  372.     FTrimCh := S;
  373.   end;
  374.  
  375. {*
  376. * Name       : Blanks
  377. * Purpose    : Return a string of Len blanks.
  378. * Parameters : Len - how many spaces
  379. * Notes      : Always seem to need a blank strings, so it is worth a
  380. *              separate routine.
  381. *}
  382. Function Blanks(Len : Byte): String;
  383.  
  384.   var
  385.     S : String;
  386.  
  387.   begin
  388.     FillChar(S[1], Len, ' ');
  389.     Byte(S[0]) := Len;
  390.     Blanks := S;
  391.   end;
  392.  
  393. {*
  394. * Name       : Chars
  395. * Purpose    : Return a string of Len char of Ch.
  396. * Parameters : Len - how many chars
  397. *              Ch - the desired character
  398. *}
  399. Function Chars(Len : Byte;
  400.                Ch  : Char): String;
  401.  
  402.   var
  403.     S : String;
  404.  
  405.   begin
  406.     FillChar(S[1], Len, Ch);
  407.     Byte(S[0]) := Len;
  408.     Chars := S;
  409.   end;
  410.  
  411. {*
  412. * Name       : CopyInto
  413. * Purpose    : Copy InStr into OutStr at column Col.
  414. * Parameters : InStr - the string to be inserted
  415. *              Col   - where to insert
  416. *              OutStr- the string to insert into, and result
  417. * Notes      : This routine is great for for creating formated output.
  418. *              This is not just another INSERT. It does not move any chars
  419. *              like insert, it just overwrites the existing string. Will
  420. *              not copy beyond the end of the Destination string.
  421. *              Basically, you just make a string of all blanks the desired
  422. *              length, then copy other strings into it at fixed columns.
  423. *}
  424. Procedure CopyInto(const InStr  : String;
  425.                          Column : Byte;
  426.                      var OutStr : String);
  427.  
  428.   begin
  429.     if (Byte(InStr[0]) <> 0) then
  430.     begin
  431.       if (Column > Byte(OutStr[0])) then
  432.         EXIT
  433.       else if (Column + Byte(InStr[0]) - 1 > Byte(OutStr[0])) then
  434.         Move(InStr[1], OutStr[Column], Byte(OutStr[0]) - Column + 1)
  435.       else
  436.         Move(InStr[1], OutStr[Column], Byte(InStr[0]));
  437.     end;
  438.   end;
  439.  
  440. Function FCopyInto(const InStr  : String;
  441.                          Column : Byte;
  442.                          OutStr : String): String;
  443.   begin
  444.     CopyInto(InStr, Column, OutStr);
  445.     FCopyInto := OutStr;
  446.   end;
  447.  
  448. {*
  449. * Name       : Strip
  450. * Purpose    : Remove the characters in Chars from S.
  451. * Parameters : S - the input string
  452. *              Chars - set of characters to be removed
  453. *}
  454. Procedure Strip(var   S     : String;
  455.                 const Chars : TbxCharSet);
  456.  
  457.   var
  458.     i,j  : Byte;
  459.  
  460.   begin
  461.     j := 0;
  462.  
  463.     for i := 1 to Byte(S[0]) do
  464.       if not (S[i] in Chars) then
  465.       begin
  466.         Inc(j);
  467.         S[j] := S[i];
  468.       end;
  469.  
  470.     Byte(S[0]) := j;
  471.   end;
  472.  
  473. Function FStrip(S : String;
  474.                 const Chars : TbxCharSet): String;
  475.   begin
  476.     Strip(S, Chars);
  477.     FStrip := S;
  478.   end;
  479.  
  480. {*
  481. * Name       : TrimLeadZero
  482. * Purpose    : Return a string with leading zeros "0" removed.
  483. * Parameters : S - string to trim
  484. *}
  485. Procedure TrimLeadZero(var S : String);
  486.  
  487.   var
  488.     i : Byte;
  489.  
  490.   begin
  491.     i := 1;
  492.  
  493.     while (i <= Byte(S[0])) and (S[i] = '0') do
  494.       Inc(i);
  495.  
  496.     if (i > 1) then
  497.     begin
  498.       Byte(S[0]) := Byte(S[0]) - i + 1;
  499.       Move(S[i], S[1], Byte(S[0]));
  500.     end;
  501.   end;
  502.  
  503. Function FTrimLeadZero(S : String): String;
  504.   begin
  505.     TrimLeadZero(S);
  506.     FTrimLeadZero := S;
  507.   end;
  508.  
  509. {*
  510. * Name       : AllBlanks
  511. * Purpose    : Test for an emtpy string.
  512. * Parameters : S - the string to test.
  513. * Notes      : Tests for both spaces and a null string.
  514. *}
  515. Function AllBlanks(const S : String): Boolean;
  516.  
  517.   var
  518.     i : Byte;
  519.  
  520.   begin
  521.     i := Byte(S[0]);
  522.  
  523.     While (i > 0) and (S[i] = ' ') do
  524.       Dec(i);
  525.  
  526.     AllBlanks := (i = 0);
  527.   end;
  528.  
  529. {*
  530. * Name       : TruncateStr
  531. * Purpose    : Truncate a string to the given length.
  532. * Parameters : S - the string to chop
  533. *              Len - the desired string length
  534. * Notes      : Only shortens does not lengthen.
  535. *}
  536. Procedure TruncateStr(var S   : String;
  537.                           Len : Byte);
  538.   begin
  539.     if (Byte(S[0]) > Len) then
  540.       Byte(S[0]) := Len;
  541.   end;
  542.  
  543. Function FTruncateStr(S   : String;
  544.                       Len : Byte): String;
  545.   begin
  546.     TruncateStr(S, Len);
  547.     FTruncateStr := S;
  548.   end;
  549.  
  550. {*
  551. * Name       : HexString
  552. * Purpose    : Convert a LongInt to a hexadecimal string.
  553. * Parameters : I - the number to convert
  554. *}
  555. Function HexString(I : LongInt): String;
  556.  
  557.   var
  558.     S : String;
  559.  
  560.   begin
  561.     With TbxLong(I) do
  562.     begin
  563.       S[0] := #9;
  564.       S[1] := '$';
  565.       S[2] := HexDigits[Hi(High) shr $4];
  566.       S[3] := HexDigits[Hi(High) and $F];
  567.       S[4] := HexDigits[Lo(High) shr $4];
  568.       S[5] := HexDigits[Lo(High) and $F];
  569.       S[6] := HexDigits[Hi(Low)  shr $4];
  570.       S[7] := HexDigits[Hi(Low)  and $F];
  571.       S[8] := HexDigits[Lo(Low)  shr $4];
  572.       S[9] := HexDigits[Lo(Low)  and $F];
  573.     end;
  574.  
  575.     { this will remove leading zeros
  576.     while (S[2] = '0') and (Length(S) > 2) do
  577.       Delete(S, 2, 1);
  578.     }
  579.  
  580.     HexString := S;
  581.   end;
  582.  
  583. {*
  584. * Name       : FormatF
  585. * Purpose    : Create a formatted string from a floating point number.
  586. * Parameters : Mask - the output formatting mask
  587. *              Dbl  - the number to format
  588. *              DP   - Number of digits to the left of decimal place to
  589. *                     retain in the output. If DP is negative the number of
  590. *                     the digits to the left is determined strictly for the
  591. *                     output mask.
  592. * Notes      : The maximum mask size is 30 characters.
  593. *
  594. *              The three characters #,@,& serve as place holders in the
  595. *              mask for the digits in the output. All other characters are
  596. *              copied from the mask to the output unchanged.
  597. *
  598. *              In the output any unused # is replaced by a space, any
  599. *              unused @ is replaced by zero, and any unused & is deleted.
  600. *              The #,@,& can be mixed as desired in the mask. Given the
  601. *              same mask, calls to FormatF with different valuse of DP will
  602. *              return strings with the decimal point aligned.
  603. *
  604. *              If a number is too large to fit in the given mask, all
  605. *              digits in the output will be set to *.
  606. *
  607. *              Some examples :
  608. *
  609. *              Input                                     Output
  610. *              ────────────────────────────────────────────────────────────
  611. *              FormatF('#####.####', 12345.6789, 4))     12345.6789
  612. *              FormatF('#####.####', 12345.6789, 3))     12345.679
  613. *              FormatF('#####.####', 1234.5678, 3))       1234.568
  614. *              FormatF('#####.####', 12345.6789, -1))    12345.6789
  615. *              FormatF('##,###.###,#', 12345.6789, 4)    12,345.678,9
  616. *              FormatF('$ ##,###.####', 12345.6789, 4)   $ 12,345.6789
  617. *              FormatF('$ ##,###.####', 123.4, 2)        $    123.4
  618. *              FormatF('$ ##,###.@@@@', 12345.6, 1)      $ 12,345.6000
  619. *              FormatF('$ &&,&&&.@@@@', 1234.56, 2)      $ 1,234.5600
  620. *              FormatF('$ &&,&&&.@@@@', 123.4, 2)        $ 123.4000
  621. *              FormatF('#####.####', 9999999.9999, 4)    *****.****
  622. *
  623. *}
  624. {$IFOPT N+}
  625. Function FormatF(const Mask : TbxNumberMask;
  626.                        Flt  : Double;
  627.                        DP   : Integer): String;
  628. {$ELSE}
  629. Function FormatF(const Mask : TbxNumberMask;
  630.                        Flt  : Real;
  631.                        DP   : Integer): String;
  632. {$ENDIF}
  633.  
  634.   var
  635.     RDigits : Byte;
  636.     LDigits : Byte;
  637.     DPos    : Byte;
  638.     Width   : Byte;
  639.     i       : Integer;
  640.     j       : Integer;
  641.     Left    : Boolean;
  642.     Num     : TbxNumberMask;
  643.     Temp    : TbxNumberMask;
  644.  
  645.   begin
  646.     Temp    := Mask;
  647.     { count digits to left and right of decimal point }
  648.     Left    := True;
  649.     RDigits := 0;
  650.     LDigits := 0;
  651.     DPos    := 0;
  652.  
  653.     for i := 1 to Length(Mask) do
  654.     begin
  655.       Case Mask[i] of
  656.         '@', '#', '&' :
  657.           begin
  658.             if Left then
  659.               Inc(LDigits)
  660.             else
  661.               Inc(RDigits);
  662.           end;
  663.  
  664.         '.' :
  665.           begin
  666.             Left := False;
  667.             DPos := i;
  668.           end;
  669.       end; {CASE}
  670.     end; {FOR}
  671.  
  672.     { adjust digits to right as needed  }
  673.     if (DP < 0) or (DP > RDigits) then
  674.       DP := RDigits;
  675.  
  676.     { calculate the total width, including decimal point  }
  677.     Width := LDigits + DP;
  678.  
  679.     if (DP > 0) then
  680.       Inc(Width);
  681.  
  682.     { convert value to string }
  683.     Str(Flt:Width:DP, Num);
  684.  
  685.     { copy the the digits left of decimal point,
  686.       from the decimal point and proceeding to the left
  687.     }
  688.     j := DPos - 1;
  689.     i := Length(Num) - DP;
  690.  
  691.     if (DP <> 0) then
  692.       Dec(i);
  693.  
  694.     While (i > 0) and (j > 0) do
  695.     begin
  696.       Case Temp[j] of
  697.         '@', '#', '&' :
  698.           begin
  699.             if (Num[i] = ' ') then
  700.             begin
  701.               i := 0;
  702.             end
  703.  
  704.             else
  705.             begin
  706.               Temp[j] := Num[i];
  707.               Dec(i);
  708.             end;
  709.           end;
  710.       end; {CASE}
  711.  
  712.       Dec(j);
  713.     end; {WHILE}
  714.  
  715.  
  716.     if (i = 0) then
  717.     begin
  718.       { copy the the digits right of decimal point,
  719.         from the decimal point and proceeding to the right
  720.       }
  721.       j := DPos + 1;
  722.       i := Length(Num) - DP + 1;
  723.  
  724.       While (i <= Length(Num)) and (j <= Length(Temp)) do
  725.       begin
  726.         Case Temp[j] of
  727.           '@', '#', '&' :
  728.             begin
  729.               Temp[j] := Num[i];
  730.               Inc(i);
  731.             end;
  732.         end; {CASE}
  733.  
  734.         Inc(j);
  735.       end; {WHILE}
  736.  
  737.       { get rid of any unneeded commas and formatting chars }
  738.       j := 0;
  739.       Num := '';
  740.  
  741.       for i := 1 to Length(Temp) do
  742.         Case Temp[i] of
  743.           '#' :
  744.             begin
  745.               Inc(j);
  746.               Num[j] := ' ';
  747.             end;
  748.  
  749.           '@' :
  750.             begin
  751.               Inc(j);
  752.               Num[j] := '0';
  753.             end;
  754.  
  755.           ',' :
  756.             begin
  757.               if (i > 1) and (i < Length(Temp)) then
  758.               begin
  759.                 if ((Temp[i - 1] = '#') or (Temp[i + 1] = '#')) then
  760.                 begin
  761.                   Inc(j);
  762.                   Num[j] := ' '
  763.                 end
  764.  
  765.                 else if (Temp[i - 1] <> '&') and (Temp[i + 1] <> '&') then
  766.                 begin
  767.                   Inc(j);
  768.                   Num[j] := Temp[i];
  769.                 end;
  770.               end
  771.  
  772.               else if (i < Length(Temp)) and (Temp[i + 1] <> '&') then
  773.               begin
  774.                 Inc(j);
  775.                 Num[j] := ' '
  776.               end
  777.  
  778.               else if (i > 1) and (Temp[i - 1] <> '&') then
  779.               begin
  780.                 Inc(j);
  781.                 Num[j] := ' '
  782.               end;
  783.             end;
  784.  
  785.           '&' :
  786.             begin
  787.             end;
  788.  
  789.           else
  790.           begin
  791.             Inc(j);
  792.             Num[j] := Temp[i];
  793.           end;
  794.         end; {CASE}
  795.  
  796.       Byte(Num[0]) := j;
  797.     end
  798.  
  799.     else  { ERROR!!!! - the number was to big for the mask  }
  800.     begin
  801.       Num := '';
  802.  
  803.       for i := 1 to Length(Mask) do
  804.         Case Mask[i] of
  805.           '@', '#', '&' :
  806.             Num[i] := '*';
  807.           else
  808.             Num[i] := Mask[i];
  809.         end; {CASE}
  810.  
  811.       Byte(Num[0]) := Length(Mask);
  812.     end;
  813.  
  814.     FormatF := Num;
  815.   end;
  816.  
  817. {*
  818. * Name       : FormatI
  819. * Purpose    : Create a formatted string from an integer number.
  820. * Parameters : Mask - the output formatting mask
  821. *              long - the number to format
  822. * Notes      : The maximum mask size is 30 characters.
  823. *
  824. *              The three characters #,@,& serve as place holders in the
  825. *              mask for the digits in the output. All other characters are
  826. *              copied from the mask to the output unchanged.
  827. *
  828. *              In the output any unused # is replaced by a space, any
  829. *              unused @ is replaced by zero, and any unused & is deleted.
  830. *              The #,@,& can be mixed as desired in the mask.
  831. *
  832. *              If a number is too large to fit in the given mask, all
  833. *              digits in the output will be set to *.
  834. *
  835. *              Some examples :
  836. *
  837. *              Input                                     Output
  838. *              ────────────────────────────────────────────────────────────
  839. *              FormatI('#####', 999)                      999
  840. *              FormatI('@@@@@', 999)                     0999
  841. *              FormatI('&&&&&', 999)                     999
  842. *              FormatI('##,###', 9999)                    9,999
  843. *              FormatI('&&,&&&', 9999)                   9,999
  844. *              FormatI('##,###', 999999)                 **,***
  845. *
  846. *}
  847. Function FormatI(const Mask : TbxNumberMask;
  848.                        Long : LongInt): String;
  849.  
  850.   var
  851.     Width   : Byte;
  852.     i       : Integer;
  853.     j       : Integer;
  854.     Num     : TbxNumberMask;
  855.     Temp    : TbxNumberMask;
  856.  
  857.   begin
  858.     Temp  := Mask;
  859.     { find the width of the output }
  860.     Width := 0;
  861.  
  862.     for i := 1 to Length(Mask) do
  863.     begin
  864.       Case Mask[i] of
  865.         '@', '#', '&' :
  866.           begin
  867.             Inc(Width)
  868.           end;
  869.       end; {CASE}
  870.     end; {FOR}
  871.  
  872.     { convert }
  873.     Str(Long:Width, Num);
  874.  
  875.     { Copy to output from right to left }
  876.     i := Length(Num);
  877.     j := Length(Temp);
  878.  
  879.     While (i > 0) and (j > 0) do
  880.     begin
  881.       Case Temp[j] of
  882.         '@', '#', '&' :
  883.           begin
  884.             if (Num[i] = ' ') then
  885.             begin
  886.               i := 0;
  887.             end
  888.  
  889.             else
  890.             begin
  891.               Temp[j] := Num[i];
  892.               Dec(i);
  893.             end;
  894.           end;
  895.       end; {CASE}
  896.  
  897.       Dec(j);
  898.     end; {WHILE}
  899.  
  900.     if (i = 0) then
  901.     begin
  902.       { get rid of any unneeded commas and formatting chars }
  903.       j := 0;
  904.       Num := '';
  905.  
  906.       for i := 1 to Length(Temp) do
  907.         Case Temp[i] of
  908.           '#' :
  909.             begin
  910.               Inc(j);
  911.               Num[j] := ' ';
  912.             end;
  913.  
  914.           '@' :
  915.             begin
  916.               Inc(j);
  917.               Num[j] := '0';
  918.             end;
  919.  
  920.           ',' :
  921.             begin
  922.               if (i > 1) and (i < Length(Temp)) then
  923.               begin
  924.                 if ((Temp[i - 1] = '#') or (Temp[i + 1] = '#')) then
  925.                 begin
  926.                   Inc(j);
  927.                   Num[j] := ' '
  928.                 end
  929.  
  930.                 else if (Temp[i - 1] <> '&') and (Temp[i + 1] <> '&') then
  931.                 begin
  932.                   Inc(j);
  933.                   Num[j] := Temp[i];
  934.                 end;
  935.               end
  936.  
  937.               else if (i < Length(Temp)) and (Temp[i + 1] <> '&') then
  938.               begin
  939.                 Inc(j);
  940.                 Num[j] := ' '
  941.               end
  942.  
  943.               else if (i > 1) and (Temp[i - 1] <> '&') then
  944.               begin
  945.                 Inc(j);
  946.                 Num[j] := ' '
  947.               end;
  948.             end;
  949.  
  950.           '&' :
  951.             begin
  952.             end;
  953.  
  954.           else
  955.           begin
  956.             Inc(j);
  957.             Num[j] := Temp[i];
  958.           end;
  959.         end; {CASE}
  960.  
  961.       Byte(Num[0]) := j;
  962.     end
  963.  
  964.     else  { ERROR!!!! - the number was to big for the mask  }
  965.     begin
  966.       Num := '';
  967.  
  968.       for i := 1 to Length(Mask) do
  969.         Case Mask[i] of
  970.           '@', '#', '&' :
  971.             Num[i] := '*';
  972.           else
  973.             Num[i] := Mask[i];
  974.         end; {CASE}
  975.  
  976.       Byte(Num[0]) := Length(Mask);
  977.     end;
  978.  
  979.     FormatI := Num;
  980.   end;
  981.  
  982.  
  983. END.
  984.